perm filename RAND[226,DBL] blob
sn#043415 filedate 1973-05-21 generic text, type T, neo UTF8
00100 (DE RANDOM () (QUOTIENT
00200 (BOOLE 1 (LSH (RANDM) -3) 7777777777) _RD))
00300
00400 (LAP RANDM SUBR)
00500 (MOVE 1 (SPECIAL _RX))
00600 (220000 1 (SPECIAL _RA))
00700 (ADD 1 (C 15460 0 616031))
00800 (404000 1 (C 377777 0 777777))
00900 (MOVEM 1 (SPECIAL _RX))
01000 (MOVEI 2 (QUOTE FIXNUM))
01100 (CALL 2 (E MAKNUM))
01200 (POPJ P)
01300 NIL
01400
01500 (DE INITRAND () (PROG (N)
01600 (SETQ _RD (PLUS 10000000000 0.0))
01700 (INITRAND1)
01800 (SETQ N (ADD1 (REMAINDER (TIME) 100)))
01900 LOOP (COND ((GREATERP (SETQ N (SUB1 N)) 0)
02000 (RANDOM) (GO LOOP)))
02100 (RETURN NIL) ]
02200
02300 (LAP INITRAND1 SUBR)
02400 (MOVE 1 (C 0 0 61356))
02500 (MOVEM 1 (SPECIAL _RX))
02600 (MOVE 1 (C 37556 0 736271))
02700 (MOVEM 1 (SPECIAL _RA))
02800 (POPJ P)
02900 NIL
03000
03100 (DE SHUFFLE (DECK) (SHUF2 (LENGTH DECK) (LENGTH DECK) DECK))
03200
03300 (DE SHUF2 (N TOT DECK) (COND
03400 ((ZEROP N) DECK)
03500 (T (SHUF2 (SUB1 N) TOT (EXCHANGE DECK N
03600 (ADD1 (FIX (TIMES TOT (RANDOM]
03700
03800 (DE EXCHANGE (L N M) (COND
03900 ((*LESS M N) (EX2 L M N))
04000 ((EQUAL N M) L)
04100 (T (EX2 L N M]
04200
04300 (DE EX2 (L N M) (COND
04400 ((EQUAL N 1) (SETQ TEMP (CAR L)) (CONS (NTH M L)
04500 (EX2 (CDR L) (SUB1 N) (SUB1 M))))
04600 ((EQUAL M 1) (CONS TEMP (CDR L)))
04700 (T (CONS (CAR L) (EX2 (CDR L) (SUB1 N) (SUB1 M]
04800
04900 (DE NTH (N L) (COND
05000 ((EQUAL N 1) (CAR L))
05100 (T (NTH (SUB1 N) (CDR L]
05200
05300 (SETQ DECK1 (QUOTE (A 2. 3. 4. 5. 6. 7. 8. 9. 10. J Q K]
05400
05500 (SETQ DECK2 (APPEND DECK1 DECK1]
05600 (SETQ DECK (APPEND DECK2 DECK2]